Celestin Apprentice 7/Apprentice-Release7.iso/Source Code/C/Applications/Moscow ML 1.42/src/mosmllib/BasicIO.sml

Text File | 1997-08-18 | 7.7 KB | 248 lines | [TEXT/R*ch]

(* BasicIO.sml *)

prim_val create_string_ : int -> string = 1 "create_string";
prim_val nth_char_ : string -> int -> char = 2 "get_nth_char";
prim_val set_nth_char_ : string -> int -> char -> unit = 3 "set_nth_char";
prim_val blit_string_ :
  string -> int -> string -> int -> int -> unit = 5 "blit_string";

fun sub_string_ s start len =
  let val res = create_string_ len
  in blit_string_ s start res 0 len; res end
;

(* Caml Light "channels" *)

prim_type in_channel and out_channel;

prim_val open_descriptor_in : int -> in_channel = 1 "open_descriptor";
        (* [open_descriptor_in fd] returns a buffered input channel
           reading from the file descriptor [fd]. The file descriptor [fd]
           must have been previously opened for reading, else the behavior is
       undefined. *)

prim_val open_descriptor_out : int -> out_channel = 1 "open_descriptor";
        (* [open_descriptor_out fd] returns a buffered output channel
           writing to the file descriptor [fd]. The file descriptor [fd]
           must have been previously opened for writing, else the behavior is
       undefined. *)

prim_val input_char_ : in_channel -> char = 1 "input_char"
        (* Read one character from the given input channel.
           Raise [Size] if there are no more characters to read. *)

prim_val caml_seek_in : in_channel -> int -> unit = 2 "seek_in"
        (* [seek_in chan pos] sets the current reading position to [pos]
           for channel [chan]. *)

prim_val caml_pos_in : in_channel -> int = 1 "pos_in";
        (* Return the current reading position for the given channel. *)

prim_val caml_close_in : in_channel -> unit = 1 "close_in"
        (* Close the given channel. Anything can happen if any of the
           above functions is called on a closed channel. *)

type file_perm = int;

datatype open_flag =
    O_RDONLY                       (* `open' read-only *)
  | O_WRONLY                       (* `open' write-only *)
  | O_RDWR                         (* `open' for reading and writing *)
  | O_APPEND                       (* `open' for appending *)
  | O_CREAT                        (* create the file if nonexistent *)
  | O_TRUNC                        (* truncate the file to 0 if it exists *)
  | O_EXCL                         (* fails if the file exists *)
  | O_BINARY                       (* `open' in binary mode *)
  | O_TEXT                         (* `open' in text mode *)
;

prim_val sys_open :
  string -> open_flag list -> file_perm -> int = 3 "sys_open"
        (* Open a file. The second argument is the opening mode.
           The third argument is the permissions to use if the file
           must be created. The result is a file descriptor opened on the
           file. *)
prim_val sys_close :
  int -> unit = 1 "sys_close"
        (* Close a file descriptor. *)

val caml_std_in  = open_descriptor_in 0
and caml_std_out = open_descriptor_out 1
and caml_std_err = open_descriptor_out 2
;

(* Moscow ML streams *)

type instream  = { closed: bool, ic: in_channel } ref;
type outstream = { closed: bool, oc: out_channel } ref;

val std_in  : instream  = ref { closed=false, ic=caml_std_in }
and std_out : outstream = ref { closed=false, oc=caml_std_out }
and std_err : outstream = ref { closed=false, oc=caml_std_err }
;

prim_val fast_input :
  in_channel -> string -> int -> int -> int = 4 "input";
prim_val fast_output :
  out_channel -> string -> int -> int -> unit = 4 "output";

fun caml_open_in_gen mode rights filename =
  open_descriptor_in (sys_open filename mode rights)
;

val caml_open_in = caml_open_in_gen [O_RDONLY, O_TEXT] 0
and caml_open_in_bin = caml_open_in_gen [O_RDONLY, O_BINARY] 0
;

fun open_out_gen mode rights filename =
  open_descriptor_out(sys_open filename mode rights)
;

prim_val s_irall : file_perm = 0 "s_irall";
prim_val s_iwall : file_perm = 0 "s_iwall";

val caml_open_out =
  open_out_gen [O_WRONLY, O_TRUNC, O_CREAT, O_TEXT] (s_irall + s_iwall)
and caml_open_out_bin =
  open_out_gen [O_WRONLY, O_TRUNC, O_CREAT, O_BINARY] (s_irall + s_iwall)
;

prim_val caml_flush : out_channel -> unit = 1 "flush"
        (* Flush the buffer associated with the given output channel,
           performing all pending writes on that channel.
           Interactive programs must be careful about flushing [std_out]
           at the right times. *)

fun caml_output_string channel s =
  fast_output channel s 0 (size s)
;

prim_val caml_close_out : out_channel -> unit = 1 "close_out"
        (* Close the given channel, flushing all buffered write operations.
       The behavior is unspecified if any of the above functions is
       called on a closed channel. *)

fun raiseIo fcn nam exn =
    raise SysErr ("BasicIO." ^ fcn ^ " on " ^ nam, NONE);

fun raiseClosed fcn nam =
    raiseIo fcn nam (Fail "Stream is closed");

fun open_in s =
  ref {closed=false, ic=caml_open_in s}
  handle exn as SysErr _ => raiseIo "open_in" s exn;

fun open_in_bin s =
  ref {closed=false, ic=caml_open_in_bin s}
  handle exn as SysErr _ => raiseIo "open_in_bin" s exn;

fun try_input_char_ ic =
  SOME (input_char_ ic)
  handle Size => NONE;

fun inputc (is as ref {closed, ic}) n =
  if closed orelse n<=0 then "" else
  let
    val buff = create_string_ n
    fun loop k =
      if k = n then buff
      else
        case fast_input ic buff k (n-k) of
            0 => sub_string_ buff 0 k
          | m => loop (k+m)
  in loop 0 end;

fun input (is, n) = inputc is n;

fun lookahead (is as ref {closed, ic}) =
  if closed then "" else
  let val pos = caml_pos_in ic in
    case try_input_char_ ic of
        NONE   => ""
      | SOME c =>
          let val () = caml_seek_in ic pos
              val s = create_string_ 1
          in set_nth_char_ s 0 c; s end
  end;

fun close_in (is as ref {closed, ic}) =
  if closed then () else
    (caml_close_in ic;
     is := { closed=true, ic=ic };
     ());

fun end_of_stream is = (lookahead is = "");

fun open_out s =
  ref {closed=false, oc=caml_open_out s}
  handle exn as SysErr _ => raiseIo "open_out" s exn;

fun open_out_bin s =
  ref {closed=false, oc=caml_open_out_bin s}
  handle exn as SysErr _ => raiseIo "open_out_bin" s exn;

fun outputc (os as ref {closed, oc}) s =
  if closed then
    raiseClosed "outputc" ""
  else
    (caml_output_string oc s;
     if os = std_err then caml_flush oc else ());

fun output (os, s) = outputc os s;

fun close_out (os as ref {closed, oc}) =
  if closed then () else
    (caml_close_out oc; os := {closed = true, oc=oc}; ());

fun flush_out (os as ref {closed, oc}) =
  if closed then
    raiseClosed "flush_out" ""
  else
    caml_flush oc;

fun input_line (is as ref {closed, ic}) =
  if closed then "" else
  let val max = ref 127
      val tmp = ref (create_string_ (!max))
      fun realloc () =
      let val newmax = 2 * !max
          val newtmp = create_string_ newmax
      in
          blit_string_ (!tmp) 0 newtmp 0 (!max);
          max := newmax;
          tmp := newtmp
      end
      fun h len =
      case try_input_char_ ic of
          NONE   => sub_string_ (!tmp) 0 len
        | SOME c => (if len >= !max then realloc () else ();
             set_nth_char_ (!tmp) len c;
             if c = #"\n" then sub_string_ (!tmp) 0 (len+1)
                          else h (len+1))
  in h 0 end;

fun can_inputc (is as ref {closed, ic}) n =
  if n<0 then false else
  if closed then n=0 else
  let
    val pos = caml_pos_in ic
    val buff = create_string_ n
    val n' = fast_input ic buff 0 n
  in caml_seek_in ic pos; n' = n end;

fun can_input (is, n) = can_inputc is n;

fun open_append s =
  ref { closed=false,
        oc=open_out_gen [O_WRONLY, O_APPEND, O_CREAT, O_TEXT]
                        (s_irall + s_iwall) s }
  handle exn as SysErr _ => raiseIo "open_append" s exn;

prim_val sys_exit : int -> 'a = 1 "sys_exit";

fun exit n =
  (flush_out std_out; flush_out std_err; sys_exit n)
;

fun print s = (outputc std_out s; flush_out std_out);